home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Hardcore Visual Basic 5.0 (2nd Edition)
/
Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso
/
Code
/
TSORT.frm
< prev
next >
Wrap
Text File
|
1997-06-14
|
13KB
|
496 lines
VERSION 5.00
Object = "{2DD06898-E157-11D0-8C51-00C04FC29CEC}#1.1#0"; "ListBoxPlus.ocx"
Begin VB.Form FTestSort
Caption = "Test Sort"
ClientHeight = 6600
ClientLeft = 1215
ClientTop = 2115
ClientWidth = 5205
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "TSORT.frx":0000
LinkTopic = "Form1"
ScaleHeight = 6600
ScaleWidth = 5205
Begin ListBoxPlus.XListBoxPlus list
Height = 2565
Left = 3465
TabIndex = 17
Top = 1980
Width = 1470
_ExtentX = 2593
_ExtentY = 4233
BackColor = 16777215
ListCount = 0
ListIndex = -1
Completion = 0 'False
End
Begin VB.ListBox lstSort
Height = 840
ItemData = "TSORT.frx":0CFA
Left = 3447
List = "TSORT.frx":0D10
TabIndex = 16
Top = 420
Width = 1488
End
Begin VB.CommandButton cmdReplaceSList
Caption = "Replace..."
Height = 375
Left = 3465
TabIndex = 15
Top = 6108
Width = 1416
End
Begin VB.CommandButton cmdFindSList
Caption = "Find..."
Height = 375
Left = 3465
TabIndex = 14
Top = 4692
Width = 1416
End
Begin VB.CommandButton cmdInsertSList
Caption = "Insert..."
Height = 375
Left = 3465
TabIndex = 13
Top = 5172
Width = 1416
End
Begin VB.CommandButton cmdRemoveSList
Caption = "Remove..."
Height = 375
Left = 3465
TabIndex = 12
Top = 5652
Width = 1416
End
Begin VB.TextBox txtArray
Height = 2568
Left = 276
MultiLine = -1 'True
TabIndex = 11
Top = 1968
Width = 1476
End
Begin VB.CommandButton cmdFindArray
Caption = "Find..."
Height = 375
Left = 276
TabIndex = 10
Top = 4680
Width = 1476
End
Begin VB.CommandButton cmdRemoveCollect
Caption = "Remove..."
Height = 375
Left = 1872
TabIndex = 9
Top = 5652
Width = 1464
End
Begin VB.CommandButton cmdInsertCollect
Caption = "Insert..."
Height = 375
Left = 1872
TabIndex = 8
Top = 5172
Width = 1464
End
Begin VB.CommandButton cmdFindCollect
Caption = "Find..."
Height = 375
Left = 1872
TabIndex = 7
Top = 4692
Width = 1464
End
Begin VB.TextBox txtCollect
Height = 2595
Left = 1872
MultiLine = -1 'True
TabIndex = 3
Top = 1968
Width = 1464
End
Begin VB.CommandButton cmdExit
Cancel = -1 'True
Caption = "E&xit"
Height = 375
Left = 276
TabIndex = 1
Top = 6096
Width = 1476
End
Begin VB.CheckBox chkDirection
Caption = "High to Low"
Height = 288
Left = 3447
TabIndex = 0
Top = 72
Width = 1416
End
Begin VB.Label lbl
Caption = "Array"
Height = 216
Index = 2
Left = 276
TabIndex = 6
Top = 1728
Width = 1476
End
Begin VB.Label lbl
Caption = "Collection"
Height = 240
Index = 1
Left = 1872
TabIndex = 5
Top = 1728
Width = 1464
End
Begin VB.Label lbl
Caption = "List Box Plus"
Height = 372
Index = 0
Left = 3465
TabIndex = 4
Top = 1728
Width = 1416
End
Begin VB.Label lblOut
Height = 375
Left = 276
TabIndex = 2
Top = 120
Width = 3135
End
End
Attribute VB_Name = "FTestSort"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private aInts(1 To 10) As Variant
Private aStrs(1 To 10) As Variant
Private aConst(1 To 10) As String
Private nStrs As Collection
Private esmlMode As ESortModeList
Private helper As CSortHelper
Sub Form_Load()
Set helper = New CSortHelper
Set nStrs = New Collection
aConst(1) = "One"
aConst(2) = "two"
aConst(3) = "Three"
aConst(4) = "four"
aConst(5) = "Five"
aConst(6) = "six"
aConst(7) = "Seven"
aConst(8) = "Eight"
aConst(9) = "Nine"
aConst(10) = "ten"
aInts(1) = 5
aInts(2) = 4
aInts(3) = 9
aInts(4) = 1
aInts(5) = 7
aInts(6) = 6
aInts(7) = 3
aInts(8) = 2
aInts(9) = 10
aInts(10) = 8
aStrs(1) = "Five"
aStrs(2) = "four"
aStrs(3) = "Nine"
aStrs(4) = "One"
aStrs(5) = "Seven"
aStrs(6) = "six"
aStrs(7) = "Three"
aStrs(8) = "two"
aStrs(9) = "ten"
aStrs(10) = "Eight"
nStrs.Add "Apple"
nStrs.Add "bean"
nStrs.Add "Pear"
nStrs.Add "banana"
nStrs.Add "peach"
nStrs.Add "CarRot"
nStrs.Add "appleberry"
nStrs.Add "Tangerine"
nStrs.Add "wine"
nStrs.Add "Beer"
' Put some items in a list box
list.Clear
list.Add "BEAR"
list.Add "Lion"
list.Add "tiger"
list.Add "dog"
list.Add "ZebrA"
list.Add "kangaroo"
list.Add "ELK"
list.Add "WartHog"
list.Add "Elephant"
list.Add "stoat"
Show
lstSort.ListIndex = 0
SortAll
End Sub
Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cmdFindArray_Click()
Dim iPos As Long, vKey As Variant, f As Boolean
vKey = InputBox("Array item to find")
If esmlMode = esmSortVal Then
vKey = LookupString(aConst, vKey)
f = BSearchArray(aInts(), vKey, iPos, helper)
Else
f = BSearchArray(aStrs(), vKey, iPos, helper)
End If
If f Then
lblOut.Caption = "Found at position: " & iPos
Else
lblOut.Caption = "Insert at position: " & iPos
End If
End Sub
Private Sub cmdFindCollect_Click()
Dim iPos As Long
If BSearchCollection(nStrs, InputBox("Collection item to find: "), iPos, helper) Then
lblOut.Caption = "Found at position: " & iPos
Else
lblOut.Caption = "Insert at position: " & iPos
End If
End Sub
Private Sub cmdFindSList_Click()
Dim v As Variant
v = InputBox("List item to find: ")
On Error Resume Next
list.Current = v
If Err Then lblOut.Caption = Err.Description
End Sub
Private Sub cmdInsertCollect_Click()
Dim v As Variant, iPos As Long
v = InputBox("Collection item to insert: ")
If BSearchCollection(nStrs, v, iPos, helper) Then
lblOut.Caption = "Can't insert duplicate item: " & v
Else
lblOut.Caption = sEmpty
On Error GoTo IndexError
nStrs.Add v, , iPos
ShowCollect
End If
Exit Sub
IndexError:
' Item needs to be inserted at end of collection
nStrs.Add v
ShowCollect
End Sub
Private Sub cmdInsertSList_Click()
Dim s As String, iPos As Long
s = InputBox("List item to insert: ")
On Error Resume Next
list.Add s
If Err Then lblOut.Caption = Err.Description
End Sub
Private Sub cmdRemoveCollect_Click()
Dim v As Variant, iPos As Long
v = InputBox("Collection item to remove: ")
If IsNumeric(v) Then
iPos = Val(v)
If iPos > nStrs.Count Or iPos < 0 Then
lblOut.Caption = "Invalid index: " & iPos
Exit Sub
End If
ElseIf BSearchCollection(nStrs, v, iPos, helper) Then
lblOut.Caption = sEmpty
Else
lblOut.Caption = "Item not in collection: " & v
Exit Sub
End If
nStrs.Remove iPos
ShowCollect
End Sub
Private Sub cmdRemoveSList_Click()
Dim v As Variant, iPos As Long
v = InputBox("List item to remove: ")
On Error Resume Next
list.Remove v
If Err Then lblOut.Caption = Err.Description
End Sub
Private Sub cmdReplaceSList_Click()
Dim vGet As Variant, vPut As Variant, iPos As Long
vGet = InputBox("List item to replace: ")
vPut = InputBox("New List item: ")
On Error Resume Next
list(vGet) = vPut
If Err Then lblOut.Caption = Err.Description
End Sub
Sub chkDirection_Click()
helper.HiToLo = (chkDirection.Value = vbChecked)
list.HiToLo = (chkDirection.Value = vbChecked)
If esmlMode = esmlShuffle Or esmlMode = esmlUnsorted Then Exit Sub
SortAll
End Sub
Private Sub lstSort_Click()
esmlMode = lstSort.ListIndex
helper.SortMode = esmlMode
SortAll
End Sub
Sub ShowArray()
Dim i As Integer, s As String
Static fInitialized As Boolean
If esmlMode = esmlUnsorted Then
If fInitialized = False Then
For i = 1 To 10
s = s & aConst(aInts(i)) & sCrLf
Next
fInitialized = True
Else
Exit Sub
End If
ElseIf esmlMode = esmlSortVal Then
For i = 1 To 10
s = s & aConst(aInts(i)) & sCrLf
Next
Else
For i = 1 To 10
s = s & aStrs(i) & sCrLf
Next
End If
txtArray.Text = s
End Sub
Sub ShowCollect()
Dim i As Integer, s As String, v As Variant
s = sEmpty
For Each v In nStrs
s = s & v & sCrLf
Next
txtCollect.Text = s
End Sub
Sub SortAll()
Select Case esmlMode
Case esmlUnsorted
' Exit Sub
Case esmlSortVal
SortArray aInts(), , , helper
SortCollection nStrs, , , helper
Case esmlShuffle
ShuffleArray aStrs(), helper
ShuffleCollection nStrs, helper
Case Else
SortArray aStrs(), , , helper
SortCollection nStrs, , , helper
End Select
ShowArray
ShowCollect
list.SortMode = esmlMode
End Sub
Function LookupString(A() As String, vKey As Variant) As Integer
Dim i As Integer
For i = 1 To 10
If A(i) = vKey Then
LookupString = i
Exit Function
End If
Next
LookupString = -1 ' Not found
End Function
' Uncomment to do tests when right click on Exit button
#Const fTestListPlus = 1
#If fTestListPlus Then
Private Sub cmdExit_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
' Right click
If Button = 2 Then TestList
End Sub
' Test of some features
Private Sub TestList()
Dim s As String, i As Long
Stop
Debug.Print list(20)
Debug.Print list(3)
Debug.Print list("Lion")
On Error Resume Next
i = list("Giraffe")
Debug.Print IIf(Err, "No Giraffe", "Giraffe")
list(3) = "Deer"
list("Lion") = "Big Cat"
ShowAll
With list
Debug.Print .Item(20)
Debug.Print .Item(3)
Debug.Print .Item("Lion")
ShowAll
Debug.Print .Item("Giraffe")
.Item(3) = "Deer"
.Item("Lion") = "Big Cat"
.Current = "dog"
.Current = 1
.Current = 4
Debug.Print .Current
Debug.Print .Item(.Current)
Debug.Print .IndexItem
Debug.Print .Text
.Add "Dog"
.Add "Tigger"
.Add "dog"
.Remove "dog"
.Remove "Marten"
.Remove 5
.Remove 20
End With
ShowAll
End Sub
Private Sub ShowAll()
Dim v As Variant, s As String
For Each v In list
s = s & v & " "
Next
Debug.Print "List: " & s
End Sub
#End If